home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / gnu_tile_forth.lha / tst / prototypes.tst < prev    next >
Text File  |  1992-05-19  |  2KB  |  128 lines
  1. .( Loading Prototypes test...) cr
  2.  
  3. #include prototypes.f83
  4.  
  5. string prototypes forth definitions
  6.  
  7. .( 1: Define the forward declared error handling as messages) cr
  8.  
  9.  
  10. nil prototype Object ( -- prototype)
  11.  
  12. message write ( self -- )
  13.  
  14. Object method unknown-message ( message self -- )
  15.   .prototype space ." has no method for " .message cr abort
  16. ;
  17.  
  18. Object method unknown-slot ( slot self -- )
  19.   .prototype space ." has no slot named " .slot cr abort
  20. ;
  21.  
  22. Object method write ( self -- )
  23.   ." Object#" .
  24. ;
  25.  
  26. Object write cr
  27. Object .relations cr
  28. cr
  29.  
  30. .( 3: Create a prototype for points) cr
  31.  
  32. Object prototype Point
  33.  
  34. slot x: ( self -- value)
  35. slot y: ( self -- value)
  36.  
  37. message position ( x y self -- )
  38. message where ( self -- x y)
  39.  
  40. Point method write ( self -- )
  41.   ." Point#" dup . ." x: " dup x: . ." y: " y: .
  42. ;
  43.  
  44. Point method position ( x y self -- )
  45.   tuck -> y: -> x:
  46. ;
  47.  
  48. Point method where ( self -- x y)
  49.   dup x: swap y:
  50. ;
  51.  
  52. 0 0 Point position
  53. Point write cr
  54. Point .relations cr
  55. cr
  56.  
  57. .( 4: Show the error handling when a slot or method is missing) cr
  58.  
  59. Object x:
  60. Object position
  61.  
  62. cr
  63.  
  64. .( 5: Show different levels of data sharing through inheritance) cr
  65.  
  66. Point prototype aPoint 
  67.  
  68. aPoint .relations cr
  69. 1 aPoint -> x:
  70. aPoint .relations cr
  71. aPoint write cr
  72. aPoint x: 1+ aPoint -> x:
  73. aPoint write cr
  74. aPoint x: 2- aPoint -> y:
  75. aPoint write cr
  76. cr
  77.  
  78. .( 6: The classical account example in prototype fashion) cr
  79.  
  80. Object prototype Account
  81.  
  82. message open ( name self -- )
  83. message deposit ( money self -- )
  84. message withdraw ( money self -- )
  85.  
  86. slot owner: ( self -- value)
  87. slot balance: ( self -- value)
  88.  
  89. 0 Account -> balance:
  90.  
  91. Account method open ( owner self -- )
  92.   -> owner:
  93. ;
  94.  
  95. Account method deposit ( money self -- )
  96.   tuck balance: + swap -> balance:
  97. ;
  98.  
  99. Account method withdraw ( money self -- )
  100.   tuck balance: swap - swap -> balance:
  101. ;
  102.  
  103. Account method write ( self -- )
  104.   ." Account#" dup . ." owner: " dup owner: $print ."  balance: " balance: .
  105. ;
  106.  
  107. Account .relations cr
  108. cr
  109.  
  110. .( 7: Create an account and deposit and withdraw some money) cr
  111.  
  112. Account prototype anAccount
  113. " Mikael" anAccount open
  114. anAccount write cr
  115. 100 anAccount deposit
  116. anAccount write cr
  117. 98 anAccount withdraw
  118. anAccount balance: . cr
  119. cr
  120.  
  121. .( 8: More error message testing) cr
  122.  
  123. anAccount x:
  124. anAccount position
  125.  
  126. forth only
  127.  
  128.